{-# LANGUAGE TypeFamilies               #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Majalan.Base.Advance
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- An event list with cursor position and /advancing/.
--
-- This module is expected to be the building block for symbolic
-- note-lists.
--
--------------------------------------------------------------------------------

module Majalan.Base.Advance
  ( 
    Advance
  , CursorPos
  , runAdvance
  , evalAdvance
  , execAdvance

  , aevent
  , aevent_

  , aeventNoWidth
  , aeventNoWidth_

  , advanceCursor

  , aeventB1
  , aeventB2
  , aeventB3
  , aeventB4
  , aeventB5

  ) where


import Majalan.Base.Behavior
import Majalan.Base.Context
import Majalan.Base.Event
import Majalan.Base.EventList
import Majalan.Base.Internal.Base

import Control.Applicative
import Control.Monad
import Data.Monoid


--
-- NOTES
--
-- Always use seconds (rather than something symbolic) then
-- we don\'t need to worry about interpreting time Ctx. 
--

type CursorPos = Seconds




newtype Advance uctx a = Advance { 
    getAdvance :: CursorPos -> EventList uctx (CursorPos, a) }


type instance UserCtx (Advance uctx) = uctx

instance Functor (Advance uctx) where
  fmap f ma = Advance $ \s -> 
                getAdvance ma s >>= \(s1,a) -> return (s1, f a)


instance Applicative (Advance uctx) where
  pure a    = Advance $ \s -> return (s,a)
  mf <*> ma = Advance $ \s -> 
                getAdvance mf s   >>= \(s1,f) ->
                getAdvance ma s1  >>= \(s2,a) ->
                return (s2, f a)

instance Monad (Advance uctx) where
  return    = pure
  ma >>= k  = Advance $ \s -> 
                getAdvance ma s >>= \(s1,a) -> getAdvance (k a) s1
            
instance Monoid a => Monoid (Advance uctx a) where
  mempty    = Advance $ \s -> return (s, mempty)
  mappend   = hcat


instance ContextM (Advance uctx) where
  askCtx        = liftEventList askCtx
  localize f ma = Advance $ \s -> localize f (getAdvance ma s)



liftEventList :: EventList uctx a -> Advance uctx a
liftEventList ma = Advance $ \s -> ma >>= \a -> return (s,a)


-- Once we have curpos pos, we can have a useful hcat...
hcat :: Monoid a => Advance uctx a -> Advance uctx a -> Advance uctx a
hcat ma mb = Advance $ \s -> 
    getAdvance ma s   >>= \(s1,a) ->
    getAdvance mb s1  >>= \(s2,b) ->
    return (s2, a <> b)


-- Advance is expected to used to implement more
-- user-friendly (musical) objects, hence we have a set of /run/ 
-- names cf. the state monad.
-- 

runAdvance :: CursorPos -> Advance uctx a -> EventList uctx (CursorPos, a)
runAdvance pos ma = getAdvance ma pos

evalAdvance :: CursorPos -> Advance uctx a -> EventList uctx a
evalAdvance pos = fmap snd . runAdvance pos


execAdvance :: CursorPos -> Advance uctx a -> EventList uctx CursorPos
execAdvance pos = fmap fst . runAdvance pos





-- | Four operations are need to render symbolic note-lists.
-- 
-- 1. note - tell event and increase cursor pos.
-- 
-- 2. noteZeroWidth - tell event, do not increase cursor pos.
-- 
-- 3. advance - increase cursor pos (cf. a rest)
--
-- 4. impulse - tell an inpulse at current position
-- 
-- We use a prefix `tell` as client code may want the nice names
-- like note.
-- 
-- With these operations chords are several noteZeroWidth then an
-- advance of the chord duration.
--


-- This is a poor API - there should be a single param for 
-- width/duration, delegating to the event as to how it is 
-- interpreted.
--


-- aevent_ :: Seconds -> Event uctx a -> Advance uctx ()
-- aevent_ drn ma = aevent drn ma >> return ()

-- TODO - this should be memorable with @aevent_@ being forgetful.

aevent :: Seconds -> Event uctx a -> Advance uctx a
aevent drn ma = Advance $ \s -> event s drn ma >>= \a -> return (s+drn, a)

aevent_ :: Seconds -> Event uctx a -> Advance uctx ()
aevent_ drn ma = void $ aevent drn ma 



aeventNoWidth :: Seconds -> Event uctx a -> Advance uctx a
aeventNoWidth drn ma = Advance $ \s -> event s drn ma >>= \a -> return (s, a)

aeventNoWidth_ :: Seconds -> Event uctx a -> Advance uctx ()
aeventNoWidth_ drn ma = void $ aeventNoWidth drn ma

advanceCursor :: Seconds -> Advance uctx ()
advanceCursor delta = Advance $ \s -> return (s+delta, ())


aeventB1 :: Seconds
         -> Behavior b1 
         -> EventB1 b1 uctx a
         -> Advance uctx a
aeventB1 drn beh1 fn = Advance $ \s -> 
    eventB1 s drn beh1 fn >>= \a -> return (s+drn, a)


aeventB2 :: Seconds
         -> Behavior b1 -> Behavior b2 
         -> EventB2 b1 b2 uctx a
         -> Advance uctx a
aeventB2 drn beh1 beh2 fn = Advance $ \s -> 
    eventB2 s drn beh1 beh2 fn >>= \a -> return (s+drn, a)


aeventB3 :: Seconds
         -> Behavior b1 -> Behavior b2 -> Behavior b3
         -> EventB3 b1 b2 b3 uctx a
         -> Advance uctx a
aeventB3 drn beh1 beh2 beh3 fn = Advance $ \s -> 
    eventB3 s drn beh1 beh2 beh3 fn >>= \a -> return (s+drn, a)



aeventB4 :: Seconds 
         -> Behavior b1 -> Behavior b2 -> Behavior b3 -> Behavior b4
         -> EventB4 b1 b2 b3 b4 uctx a
         -> Advance uctx a
aeventB4 drn beh1 beh2 beh3 beh4 fn = Advance $ \s -> 
    eventB4 s drn beh1 beh2 beh3 beh4 fn >>= \a -> return (s+drn, a)



aeventB5 :: Seconds
         -> Behavior b1 -> Behavior b2 
         -> Behavior b3 -> Behavior b4 -> Behavior b5
         -> EventB5 b1 b2 b3 b4 b5 uctx a
         -> Advance uctx a
aeventB5 drn beh1 beh2 beh3 beh4 beh5 fn = Advance $ \s -> 
    eventB5 s drn beh1 beh2 beh3 beh4 beh5 fn >>= \a -> return (s+drn, a)


